home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / instruct.emc < prev    next >
Lisp/Scheme  |  1993-07-12  |  11KB  |  330 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: instructions.em
  4. ;; Date: Fri Dec  6 00:40:15 1991
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;   List of instructions generated by the compiler
  9. ;;
  10. #include "iset.h"
  11. (defmodule instruct
  12.   (standard0
  13.    list-fns
  14.    scan-args
  15.  
  16.    i-macros
  17.    )
  18.   ()
  19.   
  20.   ;; Do this with structures in the hope that some 
  21.   ;; optimisation may be possible.
  22.   
  23.   ;; abstract class
  24.   ;; 
  25.  
  26.   (defstruct instruction-info ()
  27.     ((in initarg in
  28.            accessor instruction-in-count)
  29.      (out initarg out
  30.         accessor instruction-out-count)
  31.      (stackop initarg stackop
  32.           initform ()
  33.           accessor instruct-stack-op)
  34.      (branchp initarg branch
  35.           initform nil
  36.           accessor instruction-branchp)
  37.      (sidep initarg side
  38.         initform nil
  39.         accessor instruction-sidep)
  40.      (jumpp initarg jump
  41.         initform nil
  42.         accessor instruction-jumpp)
  43.      (bytecode initarg bytecode
  44.            accessor instruction-bytecode)
  45.      (name initarg name
  46.        accessor instruction-name)
  47.      (nargs initarg nargs
  48.        accessor instruction-nargs)
  49.      (null initform ()
  50.        initarg nullp
  51.        accessor instruction-nullp)
  52.      (argwidth initform ()
  53.            initarg argtypes
  54.            accessor instruction-argtypes)
  55.      (cost-fn initform nil
  56.           initarg cost-fn
  57.           accessor instruct-cost-fn)
  58.      (cost-lit initform 1
  59.            initarg cost
  60.            reader instruct-cost-lit))
  61.     constructor make-instruction
  62.     predicate instruction-p)
  63.   
  64.   (export instruction-in-count instruction-out-count instruction-branchp 
  65.       instruction-sidep instruction-jumpp
  66.       instruction-bytecode  instruction-name 
  67.       instruction-nargs instruction-argtypes)
  68.   (defconstant *no-val* '%%**%%)
  69.  
  70.   (defstruct instruction ()
  71.     ((info initarg info
  72.        accessor i-info)
  73.      (args initarg args
  74.        initform *no-val*
  75.        accessor i-args)
  76.      (prev initform nil
  77.        accessor instruction-prev))
  78.     )
  79.  
  80.  
  81.   (defun i-nargs (x)
  82.     (instruction-nargs (i-info x)))
  83.  
  84.   (defun i-inumber (x)
  85.     (instruction-bytecode (i-info x)))
  86.  
  87.   (defun i-name (x) 
  88.     (instruction-name (i-info x)))
  89.   
  90.   (defun i-arg-ref (x n)
  91.     (vector-ref (i-args x) n))
  92.   
  93.   (defun i-link-data (x)
  94.     (i-arg-ref x 0))
  95.   
  96.   (defun i-arg-list (x)
  97.     (convert (i-args x) pair))
  98.   
  99.   (defun i-cost (i) 
  100.     (let ((inf (i-info i)))
  101.       (if (null (instruct-cost-fn inf))
  102.       (instruct-cost-lit inf)
  103.     ((instruct-cost-fn inf) i))))
  104.  
  105.   (export i-cost)
  106.  
  107.   (defun mk-imaker (name number props)
  108.     (let ((nargs (scan-args 'nargs props 0)))
  109.       (let ((istruct (apply make-instruction
  110.                 'name name 
  111.                 'bytecode number
  112.                 'nargs nargs
  113.                 props)))
  114.     (cons istruct
  115.           (lambda (x)
  116.         (make-instance instruction 'info istruct
  117.                    'args (convert x vector)))))))
  118.   
  119.   (export i-info i-arg-ref i-name i-nargs i-args
  120.       i-inumber mk-imaker i-link-data i-arg-list)
  121.  
  122.  
  123.   (defmethod generic-prin ((x instruction) stream)
  124.     (format stream "$<~a" (i-name x))
  125.     (mapcar (lambda (a) 
  126.           (format stream " ~a" a))
  127.         (convert (i-args x)
  128.              pair))
  129.     (prin ">" stream))
  130.  
  131.   ;; NB. I assume label fn's first arg is the label
  132.   ;; Really do need a nice way of doing this junk...
  133.   (defun instruction-label (x)
  134.     (vector-ref (i-args x) 0))
  135.  
  136.   ((setter setter) instruction-label
  137.    (lambda (x y)
  138.      ((setter vector-ref) (i-args x) 0 y)))
  139.  
  140.   (defun is-label-arg (arg)
  141.     (eq arg 'label))
  142.  
  143.   (defun is-label (i)
  144.     (eq (i-info i) i-label-info))
  145.   
  146.   (defun is-branch-arg (arg)
  147.     (eq arg 'branch))
  148.  
  149.   (defun is-link-arg (arg)
  150.     (eq arg 'link))
  151.  
  152.   (defun is-static-arg (arg)
  153.     (eq arg 'static))
  154.   
  155.   (defun is-null-op (x)
  156.     (instruction-nullp (i-info x)))
  157.  
  158.   (defun instruction-argwidth (i)
  159.     (mapcar argsize
  160.         (instruction-argtypes i)))
  161.  
  162.   (export instruction-label is-label
  163.       is-branch-arg is-label-arg is-link-arg is-static-arg
  164.       is-null-op instruction-argwidth)
  165.   
  166.   (defun argsize (x)
  167.     (if (numberp x)
  168.     x
  169.       (cond ((eq x 'label) 4)
  170.         ((eq x 'static) 4)
  171.         ((eq x 'link) 8)
  172.         ((eq x 'branch) 4)
  173.         (t (error "Unknown size" <clock-tick>)))))
  174.  
  175.   ;; Label abstraction...
  176.   (defconstant lab-counter (mk-counter 0))
  177.   
  178.   (defstruct label ()
  179.     ((lab-id initform (lab-counter)
  180.          reader label-id)
  181.      (installed initform nil
  182.         accessor label-installed)
  183.      (lab-refs initform nil
  184.            initarg refs
  185.            accessor lab-refs))
  186.     constructor (make-label x)
  187.     constructor (make-reffed-label-1 refs))
  188.  
  189.   (defun make-refed-label () (make-reffed-label-1 '(1)))
  190.  
  191.   (defmethod generic-prin ((x label) stream)
  192.     (format stream "#<lab: ~a>" (label-id x)))
  193.   
  194.   (defun add-lab-ref (lab ref)
  195.     ((setter lab-refs) lab (cons ref (lab-refs lab))))
  196.   
  197.   (export make-label add-lab-ref lab-refs make-refed-label)
  198.   
  199.   ;; for inline-assembler....
  200.   
  201.   (defconstant find-instruction (mk-finder))
  202.   (export find-instruction)
  203.  
  204.   (defun add-instruction (x val)
  205.     ((setter find-instruction) x val))
  206.  
  207.   ;; For pre-linked code
  208.   (defstruct inline-code-list ()
  209.     ((count initarg count reader inline-code-count)
  210.      (code initarg code reader inline-code))
  211.     constructor (make-inline-code count code)
  212.     predicate is-inline-code)
  213.   
  214.   (export inline-code-list inline-code-count inline-code make-inline-code
  215.       is-inline-code)
  216.   ;; Each instruction in turn......
  217.   ;; definstruction defines+exports aconstructor named by the instruction, 
  218.   ;; plus <instruction>-info, the relavant info instance
  219.  
  220.   ;; hanging around instructions
  221.   (definstruction nop BC_NOP in 0 out 0)
  222.  
  223.   ;; shoving stuff on the stack
  224.   
  225.   (definstruction push-global BC_PUSH_GLOBAL nargs 1 in 0 ;; args: module, index as pair
  226.     out 1 argtypes (link) cost 4)
  227.   (definstruction push-special BC_PUSH_SPECIAL nargs 1 ;; args: name of special
  228.     in 0 out 1 argtypes (1) cost 2) 
  229.   (definstruction push-static BC_PUSH_STATIC nargs 1 in 0 out 1 argtypes (static) cost 2) ;;       reference no.
  230.   (definstruction push-small-fixnum BC_PUSH_SMALL_FIXNUM nargs 1 in 0 out 1 argtypes (1) cost 2) 
  231.   (definstruction push-fixnum BC_PUSH_FIXNUM nargs 1 in 0 out 1 argtypes (4) cost 2) 
  232.   
  233.   (definstruction set-global BC_SET_STATIC in 1 out 0 side t argtypes (static) cost 2) ;; args: index 
  234.   ;; Stack reference
  235.   (definstruction nth-ref BC_PUSH_NTH nargs 1 in 0 out 1 argtypes (1) stackop t)
  236.   (definstruction nth-ref-0 BC_PUSH_NTH_0 in 0 out 1 stackop t)
  237.   (definstruction nth-ref-1 BC_PUSH_NTH_1 in 0 out 1 stackop t)
  238.   (definstruction nth-ref-2 BC_PUSH_NTH_2 in 0 out 1 stackop t)
  239.   (definstruction nth-ref-3 BC_PUSH_NTH_3 in 0 out 1 stackop t)
  240.   (definstruction set-nth BC_SET_NTH nargs 1 in 2 out 0 side t argtypes (1) stackop t)
  241.   ;; stack abuse,  ;; depth of slide, keep
  242.   (definstruction i-slide-stack BC_SLIDE_STACK nargs 2 in arg-1 out arg-2 argtypes (1 1) stackop t)
  243.   (definstruction i-slide-stack-1 BC_SLIDE_1 nargs 1 in arg-1 out 1 argtypes (1) stackop t)
  244.   (definstruction swap BC_SWAP in 2 out 2 cost 1 stackop t)
  245.   (definstruction drop BC_DROP nargs 1 in arg-1 out 0 argtypes (1) stackop t) ;; equiv to (slide-stack n 0)
  246.   (definstruction drop-1 BC_DROP_1 in arg-1 out 0 stackop t) ;; equiv to (slide-stack 1 0)
  247.   
  248.   ;; Environment hacking --- assumed to be TOS
  249.   (definstruction env-ref BC_ENV_REF nargs 2 in 1 out 1 argtypes (1 1) cost 2) ;; depth, dist
  250.   ;; depth, dist, returns new env
  251.   (definstruction set-env BC_SET_ENV nargs 2 in 2 out 1 side t argtypes (1 1) cost 2)
  252.   (definstruction make-env BC_MAKE_ENV nargs 1 in 1 out 1 argtypes (1) cost 3) ;; size
  253.   (definstruction pop-env BC_POP_ENV nargs 1 in 1 out 1 argtypes (1) cost 2) ;; how far to drop
  254.  
  255.   ;; Object reference 
  256.   (definstruction vref BC_VREF in 2 out 1 cost 1)
  257.   (definstruction set-vref BC_SET_VREF in 3 out 1 side t cost 2)
  258.   (definstruction slot-ref BC_SLOT_REF nargs 1 in 1 out 1 argtypes (1) cost 2)
  259.   (definstruction slot-ref-0 BC_SLOT_REF_0 in 1 out 1 cost 1)
  260.   (definstruction slot-ref-1 BC_SLOT_REF_1 in 1 out 1 cost 1)
  261.   (definstruction set-slot BC_SET_SLOT nargs 1 in 2 out 1 side t argtypes (1) cost 2)
  262.   (definstruction set-slot-1 BC_SET_SLOT_1  in 2 out 1 side t cost 2)
  263.  
  264.   (definstruction i-set-type BC_SET_TYPE in 1 out 1 side t cost 2)
  265.  
  266.   ;; Branches and jumps
  267.   (definstruction branch BC_BRANCH nargs 1 in 0 out 0 branch t conditional t argtypes (branch)) ;; local-label
  268.   (definstruction branch-nil BC_BRANCH_NIL nargs 1 in 0 out 0 branch t conditional t argtypes (branch)) ;; local label
  269.  
  270.   ;; Calling functions...
  271.   ;; Would be nice to be able to test for side effects near here
  272.   ;; in nargs+2, out 1
  273.   (definstruction apply-args BC_APPLY_ARGS nargs 0 in 2 out 1 side t )
  274.   (definstruction apply-any BC_APPLY_ANY nargs 1 in (+ nargs 2) out 1 side t argtypes (1))
  275.  
  276.   (definstruction apply-bvf BC_APPLY_BVF nargs 1 in (+ nargs 2) out 1 side t argtypes (1))
  277.   (definstruction apply-cfn BC_APPLY_CFN2 nargs 1 in (+ nargs 2) out 1 side t argtypes (1))
  278.   (definstruction apply-method-list BC_APPLY_METHOD_LIST nargs 0 in 2 out 1 side t)
  279.  
  280.   ;; in nargs+2, out 1
  281.   (definstruction apply-methods BC_APPLY_METHODS nargs 1 in (+ nargs 2) out 1 side t argtypes (1))
  282.   (definstruction push-label BC_PUSH_LABEL nargs 1 in 0 out 0 argtypes (branch))            ;; a label
  283.  
  284.   ;; coming back
  285.   ;; We assume that the stack is just (ret val) at this point
  286.  
  287.   (definstruction return BC_RETURN nargs 0 in 2 out 1 side t)
  288.   
  289.   ;; Leaving for real 
  290.   (definstruction i-exit BC_EXIT nargs 0 in 0 out 0 side t)
  291.  
  292.   ;; Allocation
  293.   (definstruction i-cons BC_CONS in 2 out 1 cost 2)
  294.         ;; args: size -- reads entry from stack        
  295.   (definstruction alloc-closure BC_ALLOC_CLOSURE nargs 1 in 2 out 1 argtypes (1) cost 3) 
  296.   (definstruction alloc-extended-closure BC_ALLOC_EXT_CLOSURE nargs 1 in 2 out 1 argtypes (1) cost 3) 
  297.   (definstruction alloc-thing 61 in 1 out 1)
  298.     
  299.   ;; tests
  300.   (definstruction nullp BC_NULLP in 1 out 1)
  301.   (definstruction eqp BC_EQP in 2 out 1)
  302.   (definstruction i-consp BC_CONSP in 1 out 1)
  303.     
  304.   ;; functions 
  305.   (definstruction i-assq BC_ASSQ nargs 0 in 2 out 1 cost 2)
  306.   (definstruction i-memq BC_MEMQ nargs 0 in 2 out 1 cost 2)
  307.   (definstruction i-scanq BC_SCANQ nargs 0 in 2 out 1 cost 2)
  308.  
  309.   ;; reflection (hacks)
  310.   (definstruction current-context BC_CONTEXT in 0 out 1)
  311.   (definstruction ensure-stack BC_ENSURE_STACK nargs 1 in 0 out 0 argtypes (1))
  312.  
  313.   ;; Need labels here --- essentially this is partially IR+OUTPUT
  314.  
  315.   (definstruction i-label 257 nargs 1 in 0 out 0)
  316.   
  317.   ;; so the output is readable...
  318.   (definstruction dead-code 258 nargs 0 in 0 out 0 nullp t)
  319.     
  320.   ;; User defined types
  321.   ;; from structs.h
  322.  
  323.   (defconstant bc-macro-type #x27)
  324.   (export bc-macro-type)
  325.  
  326.   ;; hack
  327.   ((setter instruct-cost-fn) i-slide-stack-info (lambda (i) (+ (i-arg-ref i 1) 2)))
  328.   ;; end module
  329.   )
  330.